home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / bbs_util / dctta005.zip / TAGSRC05.ZIP / TAGUNIT.PAS < prev   
Pascal/Delphi Source File  |  1996-06-11  |  12KB  |  360 lines
  1. {  DCTTag v0.05  -  TagUnit.Pas  -  June 11, 1996.                }
  2. {  Copyright 1995, 1996 by Dan Traczynski.  All rights reserved.  }
  3.  
  4. {    I have added support into the door driver routines so that you can    }
  5. { use the cursor keys in the program.  When a user hits the left, right,   }
  6. { up, down, and delete keys, SRead_Ch() returns ^S, ^D, ^E, ^X, and #127   }
  7. { respectively.                                                            }
  8.  
  9. {    The format of the DCTTag.Tag file is simplay a "File Of String[72]".  }
  10. { I know that this can be changed so that it is more efficient, but I      }
  11. { didn't really feel like it.                                              }
  12.  
  13. Unit TagUnit;
  14.  
  15. {*******************************} Interface {******************************}
  16.  
  17. Uses DOS, Crt, DDPlus;
  18.  
  19. { These are the constants used for the multi-coloured string writing }
  20. { procedure.  Change them to whatever you would like.                }
  21. Const UpperCase   : Byte = 15;
  22.       LowerCase   : Byte = 7;
  23.       Numbers     : Byte = 11;
  24.       Punctuation : Byte = 5;
  25.       HiAscii     : Byte = 3;
  26.  
  27. Type Str72      = String[72];
  28.  
  29. Var Tag         : Array[1..10] Of Str72;
  30.     Ch          : Char;
  31.     X           : Word;
  32.     TagsAvail   : Integer;
  33.     UdfFileName,
  34.     TagFileName : String;
  35.     NumDefined  : Byte;
  36.     UserDefined : Array[1..10] Of Str72;
  37.  
  38. Function FileExists(FName: String) : Boolean;{Does a file exist?            }
  39. Function UCase(S: String) : String;         {Converts a string to uppercase }
  40. Procedure Pause;                            {Waits for a keypress           }
  41. Procedure WriteKewl(S:String);              {Prints text colourfully        }
  42. Procedure Header;                           {Prints the header              }
  43. Procedure GetTags;                          {Gets the random taglines       }
  44. Procedure DisplayTags;                      {Displays the tags on the screen}
  45. Procedure WriteTag(S: String; I: Word);     {Writes the tagline to MSGTMP   }
  46. Procedure ClearTagList;                     {Clears tags from screen        }
  47. Procedure CustomTag(Var Tmp: String);       {Asks user for a custom tagline }
  48. Procedure TimeWarn;                         {Warns user if time is low      }
  49.  
  50. {*****************************} Implementation {***************************}
  51.  
  52. Function FileExists(FName: String) : Boolean;
  53. Var TFile : Text;
  54.     S     : String;
  55. Begin
  56.  S := FSearch(FName,'');
  57.  FileExists := S <> '';
  58. End;
  59.  
  60. {**************************************************************************}
  61.  
  62. Function UCase(S:String) : String;
  63. Var X : Byte;
  64. Begin;
  65.  For X := 1 To Length(S) Do S[X] := UpCase(S[X]);
  66.  UCase := S;
  67. End;
  68.  
  69. {**************************************************************************}
  70.  
  71. Procedure Pause;
  72. Var Ch : Char;
  73.     Z  : Word;
  74. Begin
  75.  SWrite('[PAUSED]');
  76.  SRead_Char(Ch);
  77.  For Z := 1 To 8 Do SWrite(#8' '#8);
  78. End;
  79.  
  80. {**************************************************************************}
  81.  
  82. Procedure WriteKewl(S: String);
  83. Var X : Byte;
  84. Begin
  85.  For X := 1 To Length(S) Do Begin
  86.    Case S[X] Of
  87.     'a'..'z': If Current_ForeGround <> UpperCase Then
  88.                 Set_ForeGround(UpperCase);
  89.     'A'..'Z': If Current_ForeGround <> LowerCase Then
  90.                 Set_ForeGround(LowerCase);
  91.     '0'..'9': If Current_ForeGround <> Numbers Then
  92.                 Set_ForeGround(Numbers);
  93.     '!'..'/', ':'..'@', '['..'`', '{'..'~', #127..#223, #240..#255:
  94.                            If Current_ForeGround <> Punctuation Then
  95.                              Set_ForeGround(Punctuation);
  96.     #0..#31, #224..#239 : If Current_ForeGround <> HiAscii Then
  97.                             Set_ForeGround(HiAscii);
  98.    End;
  99.   SWrite(S[X]);
  100.  End;
  101. End;
  102.  
  103. {**************************************************************************}
  104.  
  105. Procedure TimeWarn;
  106. Var Tmp : String[1];
  107. Begin
  108.   If Time_Left <= 5 Then Begin
  109.     SWrite('***  WARNING!  Less Than ');
  110.     Str(Time_Left, Tmp);
  111.     SWriteLn(Tmp + ' Minutes Left!  ***');
  112.   End;
  113. End;
  114.  
  115. {**************************************************************************}
  116.  
  117. Procedure Header;
  118. Var Tmp     : String;
  119.     TagFile : Text;
  120. Begin
  121.  SClrScr;
  122.  If Length(Board_Name) > 28 Then Board_Name[0] := #28;
  123.  SWrite(' DCTTag v0.05 │ Copyright 1995-96 Dan Traczynski ');
  124.  SWriteLn('│ ' + Board_Name + '');
  125.  SWriteLn(#13#10);
  126.  
  127.  { First check the current directory for DCTTAG.TAG, then check the }
  128.  { directory that DCTTag.Exe resides in.                            }
  129.  TagFileName := 'DCTTAG.TAG';
  130.  Assign(TagFile, TagFileName);
  131.  {$I-} Reset(TagFile); {$I+}
  132.  If IOResult <> 0 Then Begin
  133.    TagFileName := ParamStr(0);
  134.    While (TagFileName[Length(TagFileName)] <> '\') And (TagFileName <> '') Do
  135.      Dec(TagFileName[0]);
  136.    TagFileName := TagFileName + 'DCTTAG.TAG';
  137.    Assign(TagFile, TagFileName);
  138.    {$I-} Reset(TagFile); {$I+}
  139.    If IOResult <> 0 Then Begin
  140.      SWriteLn('  *** ERROR!  Unable to find DCTTAG.TAG!  Please report this to the Sysop! ***');
  141.      SWriteLn('');
  142.      Pause;
  143.      Halt;
  144.    End;
  145.  End;
  146.  Close(TagFile);
  147.  
  148.  UdfFileName := 'DCTTAG.UDF';
  149.  Assign(TagFile, UdfFileName);
  150.  {$I-} Reset(TagFile); {$I+}
  151.  If IOResult <> 0 Then Begin
  152.    UdfFileName := ParamStr(0);
  153.    While (UdfFileName[Length(UdfFileName)] <> '\') And (UdfFileName <> '') Do
  154.      Dec(UdfFileName[0]);
  155.    UdfFileName := UdfFileName + 'DCTTAG.UDF';
  156.    Assign(TagFile, UdfFileName);
  157.    {$I-} Reset(TagFile); {$I+}
  158.    If IOResult <> 0 Then Begin
  159.      SWriteLn('  *** ERROR!  Unable to find DCTTAG.UDF!  Please report this to the Sysop! ***'#13#10);
  160.      Pause;
  161.      Halt;
  162.    End;
  163.  End;
  164.  NumDefined := 0;
  165.  While Not Eof(TagFile) Do Begin
  166.    ReadLn(TagFile, Tmp);
  167.    If (Tmp[1] <> ';') And (Tmp <> '') Then Begin
  168.      Inc(NumDefined);
  169.      UserDefined[NumDefined] := Tmp;
  170.    End;
  171.  End;
  172.  If (NumDefined = 0) Then Begin
  173.    NumDefined := 3;
  174.    UserDefined[1] := 'And now for a sacred @ proverb...';
  175.    UserDefined[2] := 'And now for something completely different...';
  176.    UserDefined[3] := 'User-defined tagline coming up...';
  177.  End;
  178.  WriteKewl('Searching For Taglines...'#13#10);
  179.  SWrite('[░░░░░░░░░░░]D');
  180. End;
  181.  
  182. {**************************************************************************}
  183.  
  184. Procedure Exchange(Var Item1, Item2 : Word);
  185. Var Temp: Word;
  186. Begin
  187.  Temp := Item1;
  188.  Item1 := Item2;
  189.  Item2 := Temp;
  190. End;
  191.  
  192. {**************************************************************************}
  193.  
  194. Procedure GetTags;
  195. Var TagNum : Array[1..10] Of Word;
  196.     TagFile : File Of Str72;
  197.     Good,
  198.     Done    : Boolean;
  199.     Tmp     : String;
  200.     X, Y, Z : Integer;
  201. Begin
  202.  Assign(TagFile, TagFileName);
  203.  Reset(TagFile);
  204.  TagsAvail := FileSize(TagFile);
  205.  SWrite('█');
  206.  Randomize;
  207.  Good := False;
  208.  While Not Good Do Begin
  209.    For Y := 1 To 10 Do TagNum[Y] := Random(TagsAvail) + 1;
  210.    Done := False;
  211.    While Not Done Do Begin
  212.      Done := True;
  213.      For X := 1 To 9 Do Begin
  214.        If TagNum[X] > TagNum[X+1] Then Begin
  215.          Exchange(TagNum[X], TagNum[X+1]);
  216.          Done := False;
  217.        End;
  218.      End; { For X := 1 To 9 ... }
  219.    End; { While Not Done ... }
  220.    { Check for duplicates... }
  221.    Good := True;
  222.    For X := 1 To 9 Do If TagNum[X] = TagNum[X+1] Then Good := False;
  223.  End; { While Not Good ... }
  224.  Z := 0;
  225.  For X := 1 To 10 Do Begin
  226.    Seek(TagFile, TagNum[X] - 1);
  227.    Read(TagFile, Tag[X]);
  228.    SWrite('█');
  229.  End;
  230.  Close(TagFile);
  231. End;
  232.  
  233. {**************************************************************************}
  234.  
  235. Procedure DisplayTags;
  236. Var X, Y : Word;
  237.     TMP  : String;
  238. Begin
  239.  For X := 1 To 10 Do Begin
  240.   If X = 10 Then Tmp := '0'
  241.             Else Str(X, Tmp);
  242.   SWrite('▌' + TMP + '▐ ');
  243.   WriteKewl(Tag[X] + #13#10);
  244.  End;
  245.  If Not NoDefined Then SWriteLn('▌A▐ Add your own tagline (72 chars max).');
  246.  SWriteLn('▌R▐ Select a random tagline from the ten above.');
  247.  SWriteLn('▌S▐ Search for more taglines.');
  248.  SWriteLn('');
  249.  TimeWarn;
  250.  WriteKewl('Your Choice (ESC=No Tagline)? ');
  251. End;
  252.  
  253. {**************************************************************************}
  254.  
  255. Procedure WriteTag(S:String; I:Word);
  256. Var MsgFile : Text;
  257.     X, Y    : Byte;
  258.     Tmp     : String;
  259. Begin
  260.  Assign(MsgFile, 'MsgTmp');
  261.  Append(MsgFile);
  262.  WriteLn(MsgFile, '');
  263.  If I = 1 Then Begin
  264.    Tmp := User_Alias_Last;
  265.    If Tmp = '' Then Tmp := User_Alias_First;
  266.    If Tmp = '' Then Tmp := User_Last_Name;
  267.    If Tmp = '' Then Tmp := User_First_Name;
  268.    For X := 1 To Length(Tmp) Do
  269.      If Tmp[X] In ['A'..'Z'] Then Tmp[X] := Chr(Byte(Tmp[X]) + 32);
  270.    Tmp[1] := UpCase(Tmp[1]);
  271.    X := Random(NumDefined) + 1;
  272.    For Y := 1 To Length(UserDefined[X]) Do
  273.      If UserDefined[X][Y] = '@' Then Write(MsgFile, Tmp)
  274.                                 Else Write(MsgFile, UserDefined[X][Y]);
  275.    WriteLn(MsgFile, '');
  276.  End;
  277.  WriteLn(MsgFile, '... ' + S);
  278.  If Random(6) = 0 Then WriteLn(MsgFile, '--- DCTTag v0.05');
  279.  Close(MsgFile);
  280.  WriteKewl(#13#10'Tagline Added.  Now Returning To The BBS...'#13#10);
  281. End;
  282.  
  283. {**************************************************************************}
  284.  
  285. Procedure RandBlue;
  286. Begin
  287.  If Random(2) = 0 Then Begin
  288.   If Current_Foreground <> 9 Then SWrite('');
  289.  End Else Begin
  290.   If Current_Foreground <> 1 Then SWrite('');
  291.  End;
  292. End;
  293.  
  294. {**************************************************************************}
  295.  
  296. Procedure ClearTagList;
  297. Var X: Word;
  298. Begin
  299.  SWrite('DA');
  300.  While WhereY > 7 Do SWrite('A');
  301. End;
  302.  
  303. {**************************************************************************}
  304.  
  305. Procedure CustomTag(Var TMP : String);
  306. Var CustomFile : Text;
  307. Begin
  308.  ClearTagList;
  309.  SWriteLn(#13#10);
  310.  WriteKewl('   Enter Your Own Tagline Now...'#13#10);
  311.  SWrite('');
  312.  RandBlue; SWrite('  ┌');
  313.  For X := 1 To 74 Do Begin If Random(4) <> 0 Then RandBlue; SWrite('─'); End;
  314.  RandBlue; SWriteLn('┐');
  315.  If Current_Foreground <> 1 Then SWrite('');
  316.  SWrite('   ▐');
  317.  For X := 1 To 72 Do SWriteC(' ');
  318.  SWriteLn('▌');
  319.  RandBlue; SWrite('  └');
  320.  For X := 1 To 74 Do Begin If Random(4) <> 0 Then RandBlue; SWrite('─'); End;
  321.  RandBlue; SWriteLn('┘');
  322.  SGoto_XY(5, 11);
  323.  Current_Foreground := 15;
  324.  Current_Background := 1;
  325.  SRead(TMP);
  326.  SWriteLn('');
  327.  SWriteLn('');
  328.  Current_Foreground := 7;
  329.  Current_Background := 0;
  330.  If TMP <> '' Then Begin
  331.   WriteKewl('   Are You Sure That You Want To Append This Tagline (Y/n)? ');
  332.   Set_Foreground(7);
  333.   Repeat
  334.    SRead_Char(Ch);
  335.    Ch := UpCase(Ch);
  336.    If Ch = #13 Then Ch := 'Y';
  337.   Until Ch In ['Y', 'N'];
  338.   SWriteLn(Ch);
  339.   If (Ch = 'Y') Then WriteTag(TMP, 1) Else TMP := '';
  340.  End;
  341.  If TMP = '' Then Begin
  342.   SGoto_XY(1, 9);
  343.   SWrite(''#13#10''#13#10''#13#10''#13#10''#13#10''#13#10'');
  344.   SGoto_XY(1, 7);
  345.  End Else Begin
  346.   If Not FileExists('DctTag.New') Then Begin
  347.    Assign(CustomFile, 'DctTag.New');
  348.    ReWrite(CustomFile);
  349.    Close(CustomFile);
  350.   End;
  351.   Assign(CustomFile, 'DctTag.New');
  352.   Append(CustomFile);
  353.   WriteLn(CustomFile, TMP);
  354.   Close(CustomFile);
  355.  End;
  356. End;
  357.  
  358. {**************************************************************************}
  359.  
  360. End.